home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / shazam.exe / GCONVERT.IMP < prev    next >
Encoding:
Text File  |  1992-09-01  |  39.8 KB  |  1,184 lines
  1.    {*******************************************************************
  2.  
  3.    GCONVERT.IMP
  4.  
  5.    *******************************************************************}
  6.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  7.  
  8.    BOOLEAN
  9.  
  10.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  11.    {===================================================================
  12.  
  13.    0/1 ==> "True "/"False"
  14.  
  15.    ===================================================================}
  16. function BooleanTrueFalse    ( B : boolean ) : string ;
  17. begin
  18.    if B then
  19.       BooleanTrueFalse       := 'True '
  20.    else
  21.       BooleanTrueFalse       := 'False' ;
  22. end ;
  23.    {===================================================================
  24.  
  25.    0/1 ==> "Yes"/"No "
  26.  
  27.    ===================================================================}
  28. function BooleanYesNo        ( B : boolean ) : string ;
  29. begin
  30.    if B then
  31.       BooleanYesNo           := 'Yes'
  32.    else
  33.       BooleanYesNo           := 'No ' ;
  34. end ;
  35.    {===================================================================
  36.  
  37.    0/1 ==> "On "/"Off"
  38.  
  39.    ===================================================================}
  40. function BooleanOnOff        ( B : boolean ) : string ;
  41. begin
  42.    if B then
  43.       BooleanOnOff           := 'On '
  44.    else
  45.       BooleanOnOff           := 'Off' ;
  46. end ;
  47.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  48.  
  49.    NUMBER <-> STRING
  50.  
  51.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  52.    {===================================================================
  53.  
  54.    REAL   "999.9" --> 999.9
  55.  
  56.    ===================================================================}
  57. function StrToReal ( S : string ) : real ;
  58. var
  59.    R                         : real ;
  60.    code                      : integer ;
  61. begin
  62.    StrToReal                 := 0 ;
  63.    Val ( S , R , code ) ;
  64.    if code = 0 then
  65.       StrToReal              := R ;
  66. end ;
  67.    {===================================================================
  68.  
  69.    RANGE - need this cause "Val" isn't too bright
  70.  
  71.    ===================================================================}
  72. function Range ( S : string ; Low , High : real ) : boolean ;
  73. var
  74.    R                         : real ;
  75. begin
  76.    R                         := StrToReal ( S ) ;
  77.    Range                     := ( R >= Low ) and
  78.                                 ( R <= High ) ;
  79. end ;
  80.    {===================================================================
  81.  
  82.    BYTE   "999" -> 999
  83.  
  84.    ===================================================================}
  85. function StrToByte ( S : string ) : byte ;
  86. var
  87.    b                         : byte ;
  88.    code                      : integer ;
  89. begin
  90.    StrToByte                 := 0 ;
  91.    if not Range ( S , 0 , 255 ) then EXIT ;
  92.    Val ( S , b , code ) ;
  93.    StrToByte                 := b ;
  94. end ;
  95.    {===================================================================
  96.  
  97.    INTEGER   "999" --> 999
  98.  
  99.    ===================================================================}
  100. function StrToShort ( S : string ) : shortint ;
  101. var
  102.    i                         : shortint ;
  103.    code                      : integer ;
  104. begin
  105.    StrToShort                := 0 ;
  106.    Val ( S , i , code ) ;
  107.    if not Range ( S , -128 , 127 ) then EXIT ;
  108.    StrToShort                := i ;
  109. end ;
  110.    {===================================================================
  111.  
  112.    INTEGER   "999" --> 999
  113.  
  114.    ===================================================================}
  115. function StrToInt ( S : string ) : integer ;
  116. var
  117.    i                         : integer ;
  118.    code                      : integer ;
  119. begin
  120.    StrToInt                  := 0 ;
  121.    Val ( S , i , code ) ;
  122.    if not Range ( S , -32768 , 32767 ) then EXIT ;
  123.    StrToInt                  := i ;
  124. end ;
  125.    {===================================================================
  126.  
  127.    WORD   "999" --> 999
  128.  
  129.    ===================================================================}
  130. function StrToWord ( S : string ) : word ;
  131. var
  132.    W                         : word ;
  133.    code                      : integer ;
  134. begin
  135.    StrToWord                 := 0 ;
  136.    Val ( S , W , code ) ;
  137.    if not Range ( S , 0 , 65535 ) then EXIT ;
  138.    StrToWord                 := W ;
  139. end ;
  140.    {===================================================================
  141.  
  142.    LONG   "999" --> 999
  143.  
  144.    ===================================================================}
  145. function StrToLong ( S : string ) : longint ;
  146. var
  147.    L                         : longint ;
  148.    code                      : integer ;
  149. begin
  150.    StrToLong                 := 0 ;
  151.    Val ( S , L , code ) ;
  152.    if not Range ( S , -2147483647 , 2147483647 ) then EXIT ;
  153.    StrToLong                 := L ;
  154. end ;
  155.    {===================================================================
  156.  
  157.    Byte,Shortint,Integer,Longint,Real --> String
  158.  
  159.    ===================================================================}
  160. function NumToStr ( R : real ) : string ;
  161. var
  162.    S1 ,
  163.    S2                        : string ;
  164.    L                         : longint ;
  165. begin
  166.    L                         := Trunc ( R ) ;          { 1.23 -->   1 }
  167.    R                         := Frac ( R ) ;           { 1.23 --> .23 }
  168.    Str ( L : -1 , S1 ) ;
  169.    Str ( R : -1 : 5 , S2 ) ;
  170.    SYSTEM.delete ( S2 , 1 , 1 ) ;
  171.    S1                        := S1 + S2 ;
  172.    while S1 [ length ( S1 ) ] = '0' do
  173.       SYSTEM.delete ( S1 , length ( S1 ) , 1 ) ;
  174.    while S1 [ length ( S1 ) ] = '.' do
  175.       SYSTEM.delete ( S1 , length ( S1 ) , 1 ) ;
  176.    if S1 = '' then
  177.       S1                     := '0' ;
  178.    NumToStr                  := S1 ;
  179. end ;
  180.    {===================================================================
  181.  
  182.    DOS - When 100's or Day of week can be ignored.
  183.  
  184.    ===================================================================}
  185. procedure GetDateTime ( VAR DT : DateTime ) ;
  186. var
  187.    Sec100 ,
  188.    DoW                       : word ;
  189. begin
  190.    GetDate ( DT.Year , DT.Month , DT.Day , DoW ) ;
  191.    GetTime ( DT.Hour , DT.Min , DT.Sec , Sec100 ) ;
  192. end ;
  193.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  194.  
  195.    VALIDITY CHECKS
  196.  
  197.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  198.    {===================================================================
  199.  
  200.    LEAP YEAR - forces century if year less than 100
  201.  
  202.    ===================================================================}
  203. function IsLeapYear ( Y : longint ) : boolean ;
  204. var
  205.    DT                        : DateTime ;
  206. begin
  207.    GetDateTime ( DT ) ;
  208.    if Y < 100 then
  209.       inc ( Y , ( DT.Year div 100 ) * 100 ) ;
  210.    IsLeapYear                  := Y mod 4 = 0 ;
  211. end ;
  212.    {===================================================================
  213.  
  214.    YEAR - greater than 0
  215.  
  216.    ===================================================================}
  217. function IsYearValid ( Y : word ) : boolean ;
  218. begin
  219.    IsYearValid                 := Y > 0 ;
  220. end ;
  221.    {===================================================================
  222.  
  223.    MONTH - 1 and 12
  224.  
  225.    ===================================================================}
  226. function IsMonthValid ( M : word ) : boolean ;
  227. begin
  228.    IsMonthValid                := ( M >= 1 ) and ( M <= 12 ) ;
  229. end ;
  230.    {===================================================================
  231.  
  232.    DAY - as per month
  233.  
  234.    ===================================================================}
  235. function MaxDayForMonth ( M , Y : word ) : word ;
  236. begin
  237.    case M of
  238.    2 :
  239.       if IsLeapYear ( Y ) then
  240.          MaxDayForMonth      := 29
  241.       else
  242.          MaxDayForMonth      := 28 ;
  243.    4 ,
  244.    6,
  245.    9,
  246.    11 : MaxDayForMonth := 30 ;
  247.    else
  248.       MaxDayForMonth := 31 ;
  249.    end ;
  250. end ;
  251.    {===================================================================
  252.  
  253.    DAY - Valid for month
  254.  
  255.    ===================================================================}
  256. function IsDayValid ( M , D , Y : word ) : boolean ;
  257. begin
  258.    IsDayValid                := ( D >= 1 ) and
  259.                                 ( D <= MaxDayForMonth ( M , Y ) ) ;
  260. end ;
  261.    {===================================================================
  262.  
  263.    DATE - check all components
  264.  
  265.    ===================================================================}
  266. function IsDateValid         ( DT : DateTime ) : boolean ;
  267. begin
  268.    IsDateValid               := IsMonthValid ( DT.Month ) and
  269.                                 IsDayValid ( DT.Month , DT.Day , DT.Year ) and
  270.                                 IsYearValid ( DT.Year ) ;
  271. end ;
  272.    {===================================================================
  273.  
  274.    DATE - check all components
  275.  
  276.    ===================================================================}
  277. function IsDateStrValid ( S : string ) : boolean ;
  278. var
  279.    DT                        : DateTime ;
  280. begin
  281.    DT.Month                  := 0 ;
  282.    DT.Day                    := 0 ;
  283.    DT.Year                   := 0 ;
  284.    StrToDate ( S , DT ) ;
  285.    IsDateStrValid            := IsDateValid ( DT ) ;
  286. end ;
  287.    {===================================================================
  288.  
  289.    FORCE VALID - Set bad part to system date (today).
  290.  
  291.    ===================================================================}
  292. procedure DateForceValid ( VAR DT : DateTime ) ;
  293. var
  294.    Temp                      : DateTime ;
  295.    DoW                       : word ;
  296. begin
  297.    DOS.GetDate ( Temp.Year , Temp.Month , Temp.Day , DoW ) ;
  298.    if not IsYearValid ( DT.Year ) then
  299.       DT.Year                := Temp.Year ;
  300.    if not IsMonthValid ( DT.Month ) then
  301.       DT.Month               := Temp.Month ;
  302.    if not IsDayValid ( DT.Month , DT.Day , DT.Year ) then
  303.       DT.Day                 := MaxDayForMonth ( DT.Month , DT.Year ) ;
  304. end ;
  305.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  306.  
  307.    DATE (Utility routines to convert date, string & date-format.)
  308.  
  309.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  310.    {===================================================================
  311.  
  312.    Month to string
  313.  
  314.    ===================================================================}
  315. function MonthToStr ( M : word ) : string ;
  316. begin
  317.    case M of
  318.    1 : MonthToStr            := 'January' ;
  319.    2 : MonthToStr            := 'February' ;
  320.    3 : MonthToStr            := 'March' ;
  321.    4 : MonthToStr            := 'April' ;
  322.    5 : MonthToStr            := 'May' ;
  323.    6 : MonthToStr            := 'June' ;
  324.    7 : MonthToStr            := 'July' ;
  325.    8 : MonthToStr            := 'August' ;
  326.    9 : MonthToStr            := 'September' ;
  327.   10 : MonthToStr            := 'October' ;
  328.   11 : MonthToStr            := 'November' ;
  329.   12 : MonthToStr            := 'December' ;
  330.    else
  331.       MonthToStr             := '???' ;
  332.    end ;
  333. end ;
  334.    {===================================================================
  335.  
  336.    Determine month by least chars.
  337.  
  338.    ===================================================================}
  339. function StrToMonth ( S : string ) : byte ;
  340. begin
  341.    S                         := CopyPos ( S , 1 , 3 ) ;
  342.    S                         := StrUpCase ( S ) ;
  343.    StrToMonth                := 0 ;              { "else" too complex }
  344.    case S [ 1 ] of
  345.    'A' : case S [ 2 ] of
  346.          'P' : StrToMonth := 4 ;                              { April }
  347.          'U' : StrToMonth := 8 ;                             { August }
  348.          end ;
  349.    'D' : StrToMonth := 12 ;                                { December }
  350.    'F' : StrToMonth := 2 ;                                 { February }
  351.    'J' : case S [ 2 ] of
  352.          'A' : StrToMonth := 1 ;                            { January }
  353.          'U' : case S [ 3 ] of                              
  354.                'L' : StrToMonth := 7 ;                         { July }
  355.                'N' : StrToMonth := 6 ;                         { June }
  356.                end ;
  357.          end ;
  358.    'M' : if S [ 2 ] = 'A' then
  359.             case S [ 3 ] of
  360.             'R' : StrToMonth := 3 ;                           { March }
  361.             'Y' : StrToMonth := 5 ;                             { May }
  362.             end ;
  363.    'N' : StrToMonth := 11 ;                                { November }
  364.    'O' : StrToMonth := 10 ;                                 { October }
  365.    'S' : StrToMonth := 9 ;                                { September }
  366.    end ;
  367. end ;
  368.    {===================================================================
  369.  
  370.    "date, month, year" --> word/word/word
  371.  
  372.    Return word values for any of these formats:
  373.    1.  mm/dd/yy    ##/##/##
  374.    2.  dd.mm.yy    ##.##.##
  375.    3.  dd-Mmm-yy   ##-&??-##
  376.  
  377.    NOTE:  Date must be checked for validity!
  378.  
  379.    ===================================================================}
  380.    {-------------------------------------------------------------------
  381.    Return chars up to, but not including, "Ch".
  382.    Delete up to and including "Ch".
  383.    -------------------------------------------------------------------}
  384. function GetTo ( VAR S : string ; Ch : char ) : string ;
  385. var
  386.    b                         : byte ;
  387. begin
  388.    b                         := pos ( Ch , S ) ;
  389.    if b = 0 then
  390.    begin
  391.       GetTo                  := CopyPos ( S , 1 , length ( S ) ) ;
  392.       S                      := '' ;
  393.       EXIT ;
  394.    end ;
  395.    GetTo                     := CopyPos ( S , 1 , b - 1 ) ;
  396.    delete ( S , 1 , b ) ;
  397. end ;
  398.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  399.    ROUTINE
  400.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  401. procedure StrToDate ( S : string ; VAR DT : DateTime ) ;
  402. var
  403.    Separator                 : char ;
  404.    Mo ,
  405.    Da ,
  406.    Yr                        : string ;
  407. begin
  408.    if pos ( '/' , S ) > 0 then Separator := '/'
  409.    else
  410.    if pos ( '.' , S ) > 0 then Separator := '.'
  411.    else
  412.    if pos ( '-' , S ) > 0 then Separator := '-'
  413.    else
  414.       case DateType of
  415.         dtUS : Separator := '/' ;
  416.         dtUK : Separator := '.' ;
  417.       dtIntl : Separator := '-' ;
  418.       end ;
  419.    case Separator of
  420.    '/' :
  421.       begin
  422.          Mo                  := GetTo ( S , Separator ) ;
  423.          Da                  := GetTo ( S , Separator ) ;
  424.          Yr                  := GetTo ( S , Separator ) ;
  425.          if DateAutoAdjust then
  426.             DateType         := dtUS ;
  427.       end ;
  428.    '.' :
  429.       begin
  430.          Da                  := GetTo ( S , Separator ) ;
  431.          Mo                  := GetTo ( S , Separator ) ;
  432.          Yr                  := GetTo ( S , Separator ) ;
  433.          if DateAutoAdjust then
  434.             DateType         := dtUK ;
  435.       end ;
  436.    '-' :
  437.       begin
  438.          S                   := StrUpCase ( S ) ;
  439.          Da                  := GetTo ( S , Separator ) ;
  440.          Mo                  := GetTo ( S , Separator ) ;
  441.          Yr                  := GetTo ( S , Separator ) ;
  442.          Mo                  := NumToStr ( StrToMonth ( Mo ) ) ;
  443.          if DateAutoAdjust then
  444.             DateType         := dtIntl ;
  445.       end ;
  446.    end ;
  447.    if IsYearValid ( StrToInt ( Yr ) ) then
  448.       DT.Year                := StrToInt ( Yr ) ;
  449.    if IsMonthValid ( StrToInt ( Mo ) ) then
  450.       DT.Month               := StrToInt ( Mo ) ;
  451.    if IsDayValid ( DT.Month , StrToInt ( Da ) , DT.Year ) then
  452.       DT.Day                 := StrToInt ( Da ) ;
  453. end ;
  454.    {===================================================================
  455.  
  456.    Return date as formatted string:
  457.    1.  mm/dd/yyyy    ##/##/####
  458.    2.  dd.mm.yyyy    ##.##.####
  459.    3.  dd-Mmm-yyyy   ##-&??-####
  460.  
  461.    Also:  Sets default DateType
  462.  
  463.    ===================================================================}
  464. function DateToStr ( DT : DateTime ; Format : word ) : string ;
  465. var
  466.    Temp ,
  467.    Mo ,
  468.    Da ,
  469.    Yr                        : string ;
  470. begin
  471.    if DateAutoFill then
  472.       DateForceValid ( DT ) ;
  473.    if Format = dtIntl then
  474.    begin
  475.       Mo                     := MonthToStr ( DT.Month ) ;
  476.       if length ( Mo ) > 3 then
  477.          Mo                  := CopyPos ( Mo , 1 , 3 ) ;
  478.    end
  479.    else
  480.    begin
  481.       Mo                     := NumToStr ( DT.Month ) ;
  482.       Mo                     := PadLeft ( Mo , #32 , 2 ) ;
  483.    end ;
  484.    Da                        := NumToStr ( DT.Day ) ;
  485.    Da                        := PadLeft ( Da , #32 , 2 ) ;
  486.    Yr                        := NumToStr ( DT.Year ) ;
  487.    Yr                        := PadRight ( Yr , #32 , 4 ) ;
  488.    if not DateCentury then
  489.       delete ( Yr , 1 , 2 ) ;
  490.    case Format of
  491.    dtUS   : Temp                  := Mo + '/' + Da + '/' + Yr ;
  492.    dtUK   : Temp                  := Da + '.' + Mo + '.' + Yr ;
  493.    dtIntl : Temp                  := Da + '-' + Mo + '-' + Yr ;
  494.    else
  495.       begin
  496.          DateToStr           := '' ;
  497.          EXIT ;
  498.       end ;
  499.    end ;
  500.    Temp                      := Replace ( Temp , #32 , '' ) ;
  501.    PadRight ( Temp , #32 , 11 ) ;
  502.    DateToStr                 := Temp ;
  503.    if DateAutoAdjust then
  504.       DateType               := Format ;
  505. end ;
  506.    {===================================================================
  507.  
  508.    FORMAT
  509.  
  510.    ===================================================================}
  511. function DateFormat ( S : string ; Format : word ) : string ;
  512. var
  513.    DT                        : DateTime ;
  514. begin
  515.    DT.Month                  := 0 ;
  516.    DT.Day                    := 0 ;
  517.    DT.Year                   := 0 ;
  518.    StrToDate ( S , DT ) ;
  519.    DateFormat                := DateToStr ( DT , Format ) ;
  520. end ;
  521.    {===================================================================
  522.  
  523.    Return Mon, Tue, etc.
  524.  
  525.    ===================================================================}
  526. function DayToStr ( DayOfWeek : word ) : string ;
  527. begin
  528.    case DayOfWeek of
  529.    0 : DayToStr := 'Sunday' ;
  530.    1 : DayToStr := 'Monday' ;
  531.    2 : DayToStr := 'Tuesday' ;
  532.    3 : DayToStr := 'Wednesday' ;
  533.    4 : DayToStr := 'Thursday' ;
  534.    5 : DayToStr := 'Friday' ;
  535.    6 : DayToStr := 'Saturday' ;
  536.    else
  537.       DayToStr := '???' ;
  538.    end ;
  539. end ;
  540.      {===================================================================
  541.      JULIAN DATES - are defined differently!  Listed here by period start:
  542.      TERM           DEFINITION                                 EXAMPLE
  543.      ----           ----------                                 -------
  544.      Gregorian      Commonly used.                             31 AUG 88
  545.  
  546.      Astronomical   Days since 1 JAN 4713 B.C.                 2447405
  547.      NOTE:  A day starts at 12:00 PM noon!
  548.  
  549.      KnowledgeMan:  Days since 15 OCT 1582                     148244
  550.      NOTE:  Valid until 31 DEC 9999
  551.             Zero if before or after.
  552.  
  553.      Reflex      :  Days since 31 DEC 1899                     32385
  554.      NOTE:  Not accepted if before!
  555.  
  556.      Military    :  Last digit of year, plus daycount.         8244
  557.      NOTE:  Always a 4-digit number.
  558.  
  559.      TEST DATE:  1 JAN 1930 = 2425978
  560.      SOURCE:     Encyclopaedia Britannica, 1955 Edition
  561.     ===================================================================}
  562.    {===================================================================
  563.  
  564.    CCYY ==> CC   Returns a two-digit number from the argument.
  565.  
  566.    ===================================================================}
  567. function Century ( Y : word ) : word ;
  568. begin
  569.    Century                   := Y div 100 ;
  570. end ;
  571.    {===================================================================
  572.  
  573.    91 ==> 1991  Add current century to year, if a 2-digit year given
  574.  
  575.    ===================================================================}
  576. procedure MakeYearCentury ( VAR YY : word ) ;
  577. var
  578.    DT                        : DateTime ;
  579. begin
  580.    GetDateTime ( DT ) ;
  581.    if YY < 100 then
  582.       YY                     := ( Century ( DT.Year ) * 100 ) + YY
  583. end ;
  584.    {===================================================================
  585.  
  586.    MM, DD, YY ==> JJJJJJJJ          ASTRONOMICAL JULIAN, The Real McCoy
  587.  
  588.    ===================================================================}
  589. function ToJulian ( DT : DateTime ) : longint ;
  590. var
  591.    L                         : longint ;
  592.    i                         : integer ;
  593.    j ,
  594.    temp                      : real ;
  595.    S                         : string ;
  596. begin
  597.    if DT.Year < 100 then
  598.       MakeYearCentury ( DT.Year ) ;
  599.    Temp                      := int ( ( DT.Month - 14.0 ) / 12.0 ) ;
  600.    J                         := DT.Day - 32075.0 +
  601.    int ( 1461.0 * ( DT.Year + 4800.0 + temp ) / 4.0 ) +
  602.    int ( 367.0 * ( DT.Month - 2.0 - temp * 12.0 ) / 12.0 ) -
  603.    int ( 3.0 * int ( ( DT.Year + 4900.0 + temp ) / 100.0 ) / 4.0 ) ;
  604.    str ( J : 14 : 0 , S ) ;
  605.    val ( S , L , i ) ;
  606.    ToJulian                    := L ;
  607. end ;
  608.    {===================================================================
  609.  
  610.    JJJJJJJJ ==>  MM, DD, YYYY
  611.  
  612.    ===================================================================}
  613. procedure FromJulian ( JulianDay : real ; VAR DT : DateTime ) ;
  614. var
  615.    tempA ,
  616.    tempB                     : real ;
  617. begin
  618.    tempA                     := JulianDay + 68569.0 ;
  619.    tempB                     := int ( 4.0 * tempA / 146097.0 ) ;
  620.    tempA                     := tempA - int ( ( 146097.0 * tempB + 3.0 ) / 4.0 ) ;
  621.    DT.Year                   := trunc ( 4000.0 * ( tempA + 1.0 ) / 1461001.0 ) ;
  622.    tempA                     := tempA - int ( 1461.0 * DT.Year / 4.0 ) + 31.0 ;
  623.    DT.Month                  := trunc ( 80.0 * tempA / 2447.0 ) ;
  624.    DT.Day                    := trunc ( tempA - int ( 2447.0 * DT.Month / 80.0 ) ) ;
  625.    tempA                     := int ( DT.Month / 11.0 ) ;
  626.    DT.Month                  := trunc ( DT.Month + 2.0 - 12.0 * tempA ) ;
  627.    DT.Year                   := trunc ( 100.0 * ( tempB - 49.0 ) + DT.Year + tempA ) ;
  628. end ;
  629.    {===================================================================
  630.  
  631.    DAY COUNT
  632.  
  633.    ===================================================================}
  634. function DaysBetween ( DT1 , DT2 : DateTime ) : longint ;
  635. begin
  636.    DaysBetween               := abs ( ToJulian ( DT1 ) - ToJulian ( DT2 ) ) ;
  637. end ;
  638.    {===================================================================
  639.  
  640.    ZELLER - Use Zeller's Congruence to compute day of the week
  641.             Returns a number from 0..6, Sun..Sat (same as DOS GetDate)
  642.  
  643.    ===================================================================}
  644. function ZellerNum ( DT : DateTime ) : byte ;
  645. var
  646.   century                    : word ;
  647. begin
  648.   if DT.Month > 2
  649.     then DT.Month            := DT.Month - 2
  650.     else
  651.       begin
  652.         DT.Month             := DT.Month + 10 ;
  653.         DT.Year              := DT.Year - 1
  654.       end ;
  655.   century                    := DT.Year div 100 ;
  656.   DT.Year                    := DT.Year mod 100 ;
  657.   ZellerNum                  := ( DT.Day - 1 +
  658.                                 ( ( 13 * DT.Month - 1 ) div 5 )
  659.                                 + ( 5 * DT.Year div 4 ) +
  660.                                 century div 4 - 2 * century + 1 ) mod 7 ;
  661. end ;
  662.    {===================================================================
  663.  
  664.    Return DayOfWeek from Julian Date
  665.  
  666.    ===================================================================}
  667. function ZellerJulian ( R : real ) : byte ;
  668. var
  669.    DT                        : DateTime ;
  670. begin
  671.    FromJulian ( R , DT ) ;
  672.    ZellerJulian              := ZellerNum ( DT ) ;
  673. end ;
  674.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  675.  
  676.    TIME
  677.  
  678.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  679.    {===================================================================
  680.  
  681.    VALID
  682.  
  683.    ===================================================================}
  684. function IsTimeValid ( DT : DateTime ) : boolean ;
  685. begin
  686.    IsTimeValid               := ( DT.Hour < 24 ) and
  687.                                 ( DT.Min < 60 ) and
  688.                                 ( DT.Sec < 60 ) ;
  689. end ;
  690.    {===================================================================
  691.  
  692.    FORCE - set to system time if not valid.
  693.  
  694.    ===================================================================}
  695. procedure TimeForceValid ( VAR DT : DateTime ) ;
  696. var
  697.    SysDateTime               : DateTime ;
  698. begin
  699.    GetDateTime ( SysDateTime ) ;
  700.    if DT.Hour > 23 then
  701.       DT.Hour                := SysDateTime.Hour ;
  702.    if DT.Min > 59 then
  703.       DT.Min                 := SysDateTime.Min ;
  704.    if DT.Sec > 59 then
  705.       DT.Sec                 := SysDateTime.Sec ;
  706. end ;
  707.    {===================================================================
  708.  
  709.    DT --> "11:43:01am"   12 (am/pm) 
  710.    DT --> "23:43:01  "   24 hr (military) mode
  711.  
  712.    Note - Always allow 10 chars (am, pm or two spaces).
  713.  
  714.    ===================================================================}
  715. function TimeToStr ( DT : DateTime ; Mode24 : boolean ) : string ;
  716. var
  717.    AmPm                      : string ;
  718. begin
  719.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  720.    24 HOUR
  721.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  722.    if Mode24 then
  723.    begin
  724.       AmPm                   := #32#32 ;
  725.       TimeToStr              := PadLeft ( NumToStr ( DT.Hour ) , '0' , 2 )
  726.                                 + ':'
  727.                                 + PadLeft ( NumToStr ( DT.Min ) , '0' , 2 )
  728.                                 + ':'
  729.                                 + PadLeft ( NumToStr ( DT.Sec ) , '0' , 2 )
  730.                                 + AmPm ;
  731.       EXIT ;
  732.    end ;
  733.    {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  734.    12 HOUR
  735.    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  736.    if DT.Hour > 12 then
  737.    begin
  738.       AmPm                   := 'pm' ;
  739.       dec ( DT.Hour , 12 ) ;
  740.    end
  741.    else
  742.    begin
  743.       AmPm                   := 'am' ;
  744.       if DT.Hour = 0 then
  745.          DT.Hour             := 12 ;
  746.    end ;
  747.    TimeToStr                 := PadLeft ( NumToStr ( DT.Hour ) , #32 , 2 )
  748.                                 + ':'
  749.                                 + PadLeft ( NumToStr ( DT.Min ) , '0' , 2 )
  750.                                 + ':'
  751.                                 + PadLeft ( NumToStr ( DT.Sec ) , '0' , 2 )
  752.                                 + AmPm ;
  753. end ;
  754.    {===================================================================
  755.  
  756.    "10:43:01" --> DT
  757.  
  758.    ===================================================================}
  759. procedure StrToTime ( S : string ; VAR DT : DateTime ) ;
  760. begin
  761.    S                         := Replace ( S , ':' , #32 ) ;
  762.    DT.Hour                   := StrToWord ( pluck ( S , 1 ) ) ;
  763.    DT.Min                    := StrToWord ( pluck ( S , 2 ) ) ;
  764.    DT.Sec                    := StrToWord ( pluck ( S , 3 ) ) ;
  765. end ;
  766.    {===================================================================
  767.  
  768.    FROM
  769.  
  770.    ===================================================================}
  771. procedure FromTotalSeconds ( Seconds : longint ; VAR DT : DateTime ) ;
  772. begin
  773.    DT.Day                    := Seconds div 86400 ;
  774.    Seconds                   := Seconds mod 86400 ;
  775.    DT.Hour                   := Seconds div 3600 ;
  776.    Seconds                   := Seconds mod 3600 ;
  777.    DT.Min                    := Seconds div 60 ;
  778.    Seconds                   := Seconds MOD 60 ;
  779.    DT.Sec                    := Seconds ;
  780. end ;
  781.    {===================================================================
  782.  
  783.    TO
  784.  
  785.    ===================================================================}
  786. function ToTotalSeconds ( DT : DateTime ) : longint ;
  787. begin
  788.    ToTotalSeconds              := LONGINT ( DT.Hour ) * 3600
  789.                                 + DT.Min * 60
  790.                                 + DT.Sec ;
  791. end ;
  792.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  793.  
  794.    DURATION
  795.  
  796.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  797.    {===================================================================
  798.  
  799.    dd:hh:mm:ss --> "0 days, 0 hrs, 0 min, 0 sec"
  800.  
  801.    ===================================================================}
  802. function DurationToStr ( DT : DateTime ) : string ;
  803. begin
  804.    if DT.Day > 0 then
  805.       DurationToStr          := NumToStr ( DT.Day )
  806.                                 + ' days, '
  807.                                 + TimeToStr ( DT , TRUE )
  808.    else
  809.       DurationToStr          := TimeToStr ( DT , TRUE ) ;
  810. end ;
  811.    {===================================================================
  812.  
  813.    SECONDS - absolute
  814.  
  815.    ===================================================================}
  816. function SecondsBetween ( DT1 , DT2 : DateTime ) : longint ;
  817. begin
  818.    if CompareTime ( DT1 , DT2 ) = -1 then
  819.       SecondsBetween         := ToTotalSeconds ( DT1 ) - ToTotalSeconds ( DT2 )
  820.    else
  821.       SecondsBetween         := ToTotalSeconds ( DT2 ) - ToTotalSeconds ( DT1 ) ;
  822. end ;
  823.    {===================================================================
  824.  
  825.    DateTime1 , DateTime2 ==> ddddd:hh:mm:ss
  826.  
  827.    DURATION - days, hours, minutes, seconds (no year or month)
  828.  
  829.    ===================================================================}
  830. procedure GetDuration ( DT1 , DT2 : DateTime ; VAR Result : DateTime ) ;
  831. var
  832.    TimeDiff                  : longint ;
  833.    DayDiff                   : longint ;
  834.    Midnight                  : DateTime ;
  835.    Zero                      : DateTime ;
  836. begin
  837.    FillChar ( Result , SizeOf ( DateTime ) , #0 ) ;
  838.    FillChar ( Midnight , SizeOf ( DateTime ) , #0 ) ;
  839.    FillChar ( Zero , SizeOf ( DateTime ) , #0 ) ;
  840.    Midnight.Hour             := 24 ;
  841.    case CompareDate ( DT1 , DT2 ) of
  842.    0 : TimeDiff              := SecondsBetween ( DT1 , DT2 ) ;
  843.   -1 : TimeDiff              := SecondsBetween ( DT2 , Midnight )
  844.                                 + SecondsBetween ( Zero , DT1 ) ;
  845.    1 : TimeDiff              := SecondsBetween ( DT1 , Midnight )
  846.                                 + SecondsBetween ( Zero , DT2 ) ;
  847.    end ;
  848.    DayDiff                   := DaysBetween ( DT1 , DT2 ) - 1 ;
  849.    FromTotalSeconds ( TimeDiff , Result ) ;
  850.    if DayDiff > 0 then
  851.       inc ( Result.Day , DayDiff ) ;
  852. end ;
  853.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  854.  
  855.    FILE
  856.  
  857.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  858.    {===================================================================
  859.  
  860.    SET 
  861.  
  862.    ===================================================================}
  863. function SetFileDateTime ( S : PathStr ; VAR DT : DateTime ) : boolean ;
  864. var
  865.    Time                      : longint ;
  866.    F                         : file ;
  867.    OK                        : boolean ;
  868. begin
  869.    SetFileDateTime           := FALSE ;
  870.    DosError                  := 0 ;
  871.    OK                        := TRUE ;
  872.    PackTime ( DT , Time ) ;
  873. {$I-}
  874.    Assign ( F , S ) ;
  875.    Reset ( F ) ;
  876.    if IOResult <> 0 then OK  := FALSE ;
  877.    SetFTime ( F , Time ) ;
  878.    if IOResult <> 0 then OK  := FALSE ;
  879.    Close ( F ) ;
  880. {$I-}
  881.    if IOResult <> 0 then OK  := FALSE ;
  882.    if DosError <> 0 then OK  := FALSE ;
  883.    if not OK then EXIT ;
  884.    SetFileDateTime           := TRUE ;
  885. end ;
  886.    {===================================================================
  887.  
  888.    GET 
  889.  
  890.    ===================================================================}
  891. function GetFileDateTime ( S : PathStr ; VAR DT : DateTime ) : boolean ;
  892. var
  893.    Time                      : longint ;
  894.    F                         : file ;
  895.    OK                        : boolean ;
  896. begin
  897.    GetFileDateTime           := FALSE ;
  898.    DosError                  := 0 ;
  899.    OK                        := TRUE ;
  900.    FillChar ( DT , SizeOf ( DT ) , #0 ) ;
  901. {$I-}
  902.    Assign ( F , S ) ;
  903.    Reset ( F ) ;
  904.    if IOResult <> 0 then OK  := FALSE ;
  905.    GetFTime ( F , Time ) ;
  906.    if IOResult <> 0 then OK  := FALSE ;
  907.    Close ( F ) ;
  908. {$I-}
  909.    if IOResult <> 0 then OK  := FALSE ;
  910.    if DosError <> 0 then OK  := FALSE ;
  911.    if not OK then EXIT ;
  912.    UnpackTime ( Time , DT ) ;
  913.    GetFileDateTime           := TRUE ;
  914. end ;
  915.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  916.  
  917.    REPORT - Preset for easy formatting
  918.  
  919.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  920.    {===================================================================
  921.  
  922.    TIME --> '23:00'
  923.  
  924.    ===================================================================}
  925. function Now : string ;
  926. var
  927.    DT                        : DateTime ;
  928. begin
  929.    GetDateTime ( DT ) ;
  930.    Now                       := TimeToStr ( DT , FALSE ) ;
  931. end ;
  932.    {===================================================================
  933.  
  934.    Date --> '1-Jan-89'
  935.  
  936.    ===================================================================}
  937. function Today : string ;
  938. var
  939.    DT                        : DateTime ;
  940. begin
  941.    GetDateTime ( DT ) ;
  942.    Today                     := DateToStr ( DT , DateType ) ;
  943. end ;
  944.    {===================================================================
  945.  
  946.    Date & Time --> "1/1/1 0:0"
  947.  
  948.    ===================================================================}
  949. function DateAndTimeToStr ( DT : DateTime ; WhichDateType : word ; Mode24 : boolean ) : string ;
  950. begin
  951.    DateAndTimeToStr          := DateToStr ( DT , WhichDateType )
  952.                                 + #32
  953.                                 + TimeToStr ( DT , Mode24 ) ;
  954. end ;
  955.    {===================================================================
  956.  
  957.    FILE - return formatted date string
  958.  
  959.    ===================================================================}
  960. function FileDateStr ( S : PathStr ; WhichDateType : word ) : string ;
  961. var
  962.    DT                        : DateTime ;
  963. begin
  964.    if not GetFileDateTime ( S , DT ) then
  965.       DateForceValid ( DT ) ;
  966.    FileDateStr               := DateToStr ( DT , WhichDateType ) ;
  967. end ;
  968.    {===================================================================
  969.  
  970.    FILE - return formatted time string
  971.  
  972.    ===================================================================}
  973. function FileTimeStr ( S : PathStr ; Mode24 : boolean ) : string ;
  974. var
  975.    DT                        : DateTime ;
  976. begin
  977.    if not GetFileDateTime ( S , DT ) then
  978.       TimeForceValid ( DT ) ;
  979.    FileTimeStr               := TimeToStr ( DT , Mode24 ) ;
  980. end ;
  981.    {===================================================================
  982.  
  983.    FILE - return formatted date/time string
  984.  
  985.    ===================================================================}
  986. function FileDateTimeStr ( S : PathStr ; WhichDateType : word ; Mode24 : boolean ) : string ;
  987. var
  988.    DT                        : DateTime ;
  989.    TempDateType              : word ;
  990. begin
  991.    TempDateType              := DateType ;
  992.    if not GetFileDateTime ( S , DT ) then
  993.    begin
  994.       DateForceValid ( DT ) ;
  995.       TimeForceValid ( DT ) ;
  996.    end ;
  997.    FileDateTimeStr           := DateAndTimeToStr ( DT ,
  998.                                                    WhichDateType ,
  999.                                                    Mode24 ) ;
  1000.    DateType                  := TempDateType ;
  1001. end ;
  1002.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  1003.  
  1004.    COMPARE
  1005.    -------
  1006.    -1  First is later/newer
  1007.     0  Equal
  1008.     1  Second is later/newer
  1009.  
  1010.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  1011.    {===================================================================
  1012.  
  1013.    TIME
  1014.  
  1015.    ===================================================================}
  1016. function CompareTime ( DT1 , DT2 : DateTime ) : shortint ;
  1017. begin
  1018.    if ToTotalSeconds ( DT1 ) = ToTotalSeconds ( DT2 ) then
  1019.       CompareTime            := 0
  1020.    else
  1021.       if ToTotalSeconds ( DT1 ) > ToTotalSeconds ( DT2 ) then
  1022.          CompareTime         := -1
  1023.       else
  1024.          CompareTime         := 1 ;
  1025. end ;
  1026.    {===================================================================
  1027.  
  1028.    DATE 
  1029.  
  1030.    ===================================================================}
  1031. function CompareDate ( DT1 , DT2 : DateTime ) : shortint ;
  1032. begin
  1033.    if ToJulian ( DT1 ) = ToJulian ( DT2 ) then
  1034.    begin
  1035.       CompareDate            := 0 ;
  1036.    end
  1037.    else
  1038.       if ToJulian ( DT1 ) > ToJulian ( DT2 ) then
  1039.          CompareDate         := -1
  1040.       else
  1041.          CompareDate         := 1 ;
  1042. end ;
  1043.    {===================================================================
  1044.  
  1045.    COMPARE
  1046.  
  1047.    ===================================================================}
  1048. function CompareDateTime ( DT1 , DT2 : DateTime ) : shortint ;
  1049. begin
  1050.    if ToJulian ( DT1 ) = ToJulian ( DT2 ) then
  1051.       CompareDateTime        := CompareTime ( DT1 , DT2 )
  1052.    else
  1053.       if ToJulian ( DT1 ) > ToJulian ( DT2 ) then
  1054.          CompareDateTime     := -1
  1055.       else
  1056.          CompareDateTime     := 1 ;
  1057. end ;
  1058.    {===================================================================
  1059.  
  1060.    FILE
  1061.  
  1062.    ===================================================================}
  1063. function CompareFileDateTime ( S1 , S2 : PathStr ) : shortint ;
  1064. var
  1065.    dt1                       : DateTime ;
  1066.    dt2                       : DateTime ;
  1067. begin
  1068.    GetFileDateTime ( S1 , dt1 ) ;
  1069.    GetFileDateTime ( S2 , dt2 ) ;
  1070.    CompareFileDateTime       := CompareDateTime ( dt1 , dt2 ) ;
  1071. end ;
  1072.    {===================================================================
  1073.  
  1074.    MAX
  1075.  
  1076.    ===================================================================}
  1077. function CompareMax ( x , y : real ) : shortint ;
  1078. begin
  1079.    if x > y then CompareMax  := -1 else
  1080.    if x < y then CompareMax  := 1 else
  1081.    CompareMax                := 0 ;
  1082. end ;
  1083.    {===================================================================
  1084.  
  1085.    MIN
  1086.  
  1087.    ===================================================================}
  1088. function CompareMin ( x , y : real ) : shortint ;
  1089. begin
  1090.    if x < y then CompareMin  := -1 else
  1091.    if x > y then CompareMin  := 1 else
  1092.    CompareMin                := 0 ;
  1093. end ;
  1094.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  1095.  
  1096.    MAX & MIN
  1097.  
  1098.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  1099.    {===================================================================
  1100.  
  1101.    REAL
  1102.  
  1103.    ===================================================================}
  1104. function MaxMinReal ( x , y : real ; Max : boolean ) : real ;
  1105. begin
  1106.    MaxMinReal                := y ;
  1107.    if Max then
  1108.    begin
  1109.       if CompareMax ( x , y ) = -1 then
  1110.          MaxMinReal          := x ;
  1111.       EXIT ;
  1112.    end ;
  1113.    if CompareMin ( x , y ) = -1 then
  1114.       MaxMinReal             := x ;
  1115. end ;
  1116.    {===================================================================
  1117.  
  1118.    LONGINT
  1119.  
  1120.    ===================================================================}
  1121. function MaxMinLongint ( x , y : longint ; Max : boolean ) : longint ;
  1122. begin
  1123.    MaxMinLongint             := y ;
  1124.    if Max then
  1125.    begin
  1126.       if CompareMax ( x , y ) = -1 then
  1127.          MaxMinLongint       := x ;
  1128.       EXIT ;
  1129.    end ;
  1130.    if CompareMin ( x , y ) = -1 then
  1131.       MaxMinLongint          := x ;
  1132. end ;
  1133.    {===================================================================
  1134.  
  1135.    INTEGER
  1136.  
  1137.    ===================================================================}
  1138. function MaxMinInteger ( x , y : integer ; Max : boolean ) : integer ;
  1139. begin
  1140.    MaxMinInteger             := y ;
  1141.    if Max then
  1142.    begin
  1143.       if CompareMax ( x , y ) = -1 then
  1144.          MaxMinInteger       := x ;
  1145.       EXIT ;
  1146.    end ;
  1147.    if CompareMin ( x , y ) = -1 then
  1148.       MaxMinInteger          := x ;
  1149. end ;
  1150.    {===================================================================
  1151.  
  1152.    WORD
  1153.  
  1154.    ===================================================================}
  1155. function MaxMinWord ( x , y : word ; Max : boolean ) : word ;
  1156. begin
  1157.    MaxMinWord                := y ;
  1158.    if Max then
  1159.    begin
  1160.       if CompareMax ( x , y ) = -1 then
  1161.          MaxMinWord          := x ;
  1162.       EXIT ;
  1163.    end ;
  1164.    if CompareMin ( x , y ) = -1 then
  1165.       MaxMinWord             := x ;
  1166. end ;
  1167.    {===================================================================
  1168.  
  1169.    BYTE
  1170.  
  1171.    ===================================================================}
  1172. function MaxMinByte ( x , y : byte ; Max : boolean ) : byte ;
  1173. begin
  1174.    MaxMinByte                := y ;
  1175.    if Max then
  1176.    begin
  1177.       if CompareMax ( x , y ) = -1 then
  1178.          MaxMinByte          := x ;
  1179.       EXIT ;
  1180.    end ;
  1181.    if CompareMin ( x , y ) = -1 then
  1182.       MaxMinByte             := x ;
  1183. end ;
  1184.